Shareware Grab Bag/Shareware Grab Bag.iso/010/games.arc/CALENDAR.BAS

GW-BASIC | 1980-01-01 | 6.5 KB | 305 lines

10  ' **********************
20  ' **     CALENDAR     **
30  ' **********************
40  '
50  CLEAR
60  SCREEN 0,0,0,0
70  CLS
80  KEY OFF
90  OPTION BASE 1
100  DIM MONTH.NAME$(12),WEEK.DAY$(7)
110  FOR I = 1 TO 12
120  READ MONTH.NAME$(I)
130  NEXT I
140  DATA JANUARY,FEBRUARY,MARCH,APRIL,MAY,JUNE,JULY
150  DATA AUGUST,SEPTEMBER,OCTOBER,NOVEMBER,DECEMBER
160  FOR I = 1 TO 7
170  READ WEEK.DAY$(I)
180  NEXT I
190  DATA SUNDAY,MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY
200  LOCATE 1,29
210  PRINT "* * *  CALENDAR  * * *
220  LOCATE 7,1
230  PRINT TAB(20)"F1.   Sketch a one month calendar page
240  PRINT
250  PRINT TAB(20)"F2.   Describe a given date
260  PRINT
270  PRINT TAB(20)"F3.   Number of days between two dates
280  PRINT
290  PRINT TAB(20)"F4.   Quit
300  LOCATE 25,25
310  PRINT "PRESS A SPECIAL FUNCTION KEY";
320  ON KEY(1) GOSUB 470
330  ON KEY(2) GOSUB 1220
340  ON KEY(3) GOSUB 1650
350  ON KEY(4) GOSUB 2010
360  KEY(1) ON
370  KEY(2) ON
380  KEY(3) ON
390  KEY(4) ON
400  '
410  WHILE QUIT = NOT.YET
420  KEY.BUFFER.CLEAR$ = INKEY$
430  WEND
440  CLS
450  END
460  '
470  ' F1 Subroutine, sketch a month
480  SCREEN 0,0,1,1
490  CLS
500  LOCATE 7,20
510  INPUT "What month ";Q$
520  IF Q$ = "" THEN 1190
530  GOSUB 2150
540  GOSUB 2220
550  MONTH = VAL(Q$)
560  IF MONTH THEN 600
570  FOR I = 1 TO 12
580  IF LEFT$(MONTH.NAME$(I),3) = LEFT$(Q$,3) THEN MONTH = I
590  NEXT I
600  IF MONTH THEN 650
610  LOCATE 8,12
620  PRINT "I don't recognize the month you entered ... try again
630  BEEP
640  GOTO 500
650  LOCATE 8,12
660  PRINT SPACE$(53);
670  LOCATE 9,20
680  INPUT "What year ";Q$
690  IF Q$ = "" THEN 1190
700  YEAR = VAL(Q$)
710  IF YEAR THEN 760
720  LOCATE 10,12
730  PRINT "I don't recognize the year you entered ... try again
740  BEEP
750  GOTO 670
760  IF YEAR < 100 THEN YEAR = YEAR + 1900
770  IF YEAR > 1581 AND YEAR < 4000 THEN 810
780  PRINT "The year must be in the range 1582 to 3999 ... try again
790  BEEP
800  GOTO 670
810  DAY = 1
820  GOSUB 2300
830  DAYOFWEEK = WEEKDAY
840  TITLE$ = MONTH.NAME$(MONTH)
850  JFIRST = JULIAN
860  MONTH = MONTH + 1
870  IF MONTH > 12 THEN MONTH = 1
880  IF MONTH = 1 THEN YEAR = YEAR + 1
890  GOSUB 2300
900  MONTHDAYS = JULIAN - JFIRST
910  CLS
920  LOCATE 1,37 - LEN(TITLE$) / 2
930  PRINT TITLE$ ; YEAR + (MONTH = 1)
940  DATE = 1
950  ROW = 6
960  COL = DAYOFWEEK * 7 + 10
970  LOCATE ROW,COL - (DATE < 10)
980  PRINT DATE
990  DATE = DATE + 1
1000  IF DATE > MONTHDAYS THEN 1040
1010  DAYOFWEEK = DAYOFWEEK MOD 7 + 1
1020  IF DAYOFWEEK = 1 THEN ROW = ROW + 3
1030  GOTO 960
1040  FOR ROWLINE = 4 TO ROW + 3 STEP 3
1050  LOCATE ROWLINE,15
1060  PRINT STRING$(50,"_");
1070  NEXT ROWLINE
1080  FOR ROW2 = 4 TO ROW + 1
1090  FOR COL2 = 15 TO 65 STEP 7
1100  LOCATE ROW2,COL2
1110  IF ROW2 = 4 THEN PRINT " "; ELSE PRINT "|";
1120  NEXT COL2,ROW2
1130  FOR I = 1 TO 7
1140  LOCATE 3,7 * I + 10
1150  PRINT LEFT$(WEEK.DAY$(I),3);
1160  NEXT I
1170  BARMESS = 1
1180  GOSUB 2070
1190  SCREEN 0,0,0,0
1200  RETURN
1210  '
1220  ' F2 Subroutine, describe a date
1230  SCREEN 0,0,1,1
1240  CLS
1250  LOCATE 7,7
1260  LINE INPUT "Enter a date ... (any reasonable format) ";CAL$
1270  IF CAL$ = "" THEN 1620
1280  GOSUB 2600
1290  IF YEAR THEN 1340
1300  PRINT
1310  PRINT "Your date is unrecognizable, or isn't a valid date ... try again.
1320  BEEP
1330  GOTO 1250
1340  CLS
1350  LOCATE 5,6
1360  BS$ = CHR$(29)
1370  PRINT MONTH;"/";DAY;"/";YEAR;"can also be written as ";
1380  PRINT MONTH.NAME$(MONTH);DAY;BS$;",";YEAR;BS$;"."
1390  LOCATE 7,7
1400  PRINT "The day of the week is ";WEEK.DAY$(WEEKDAY);"."
1410  IF YEAR < 1600 THEN 1590
1420  JULIAN2 = JULIAN
1430  MONTH2 = MONTH
1440  DAY2 = DAY
1450  YEAR2 = YEAR
1460  MONTH = 12
1470  DAY = 31
1480  YEAR = YEAR - 1
1490  IF YEAR < 1582 THEN 1540
1500  GOSUB 2300
1510  YEARDAY = JULIAN2 - JULIAN
1520  LOCATE 9,7
1530  PRINT "It is day number"YEARDAY"of"YEAR2;BS$;"."
1540  YEAR = (INT(YEAR/100) - 1) * 100 + 99
1550  GOSUB 2300
1560  CENTDAY = JULIAN2 - JULIAN
1570  LOCATE 11,7
1580  PRINT "It is the"CENTDAY"day of the century.
1590  LOCATE 13,7
1600  PRINT "And the astronomical julian day number is";JULIAN2;BS$;"."
1610  GOSUB 2070
1620  SCREEN 0,0,0,0
1630  RETURN
1640  '
1650  ' F3 Subroutine, days between dates
1660  SCREEN 0,0,1,1
1670  CLS
1680  LOCATE 7,7
1690  LINE INPUT "Enter one date ... (any reasonable format) ";CAL$
1700  IF CAL$ = "" THEN 1980
1710  GOSUB 2600
1720  IF YEAR THEN 1770
1730  LOCATE 9,1
1740  PRINT "Your date is unrecognizable, or isn't a valid date ... try again.
1750  BEEP
1760  GOTO 1680
1770  MONTH3 = MONTH
1780  DAY3 = DAY
1790  YEAR3 = YEAR
1800  JULIAN3 = JULIAN
1810  LOCATE 9,1
1820  PRINT SPACE$(79);
1830  LOCATE 9,7
1840  LINE INPUT "Enter second date ... ";CAL$
1850  IF CAL$ = "" THEN 1980
1860  GOSUB 2600
1870  IF YEAR THEN 1920
1880  LOCATE 11,1
1890  PRINT "Your date is unrecognizable, or isn't a valid date ... try again.
1900  BEEP
1910  GOTO 1830
1920  NUMDAYS = ABS(JULIAN3 - JULIAN)
1930  CLS
1940  LOCATE 7,7
1950  PRINT "Between";MONTH3;"/";DAY3;"/";YEAR3;"and";
1960  PRINT MONTH;"/";DAY;"/";YEAR;"there are";NUMDAYS;"days."
1970  GOSUB 2070
1980  SCREEN 0,0,0,0
1990  RETURN
2000  '
2010  ' F4 Subroutine, set quit flag
2020  QUIT = 1
2030  RETURN
2040  '
2050  '
2060  ' Subroutine, wait for user before proceeding
2070  LOCATE 25,28
2080  IF BARMESS = 0 THEN PRINT "PRESS ANY KEY TO PROCEED";
2090  K$ = INKEY$
2100  IF K$ = "" THEN 2090
2110  BARMESS = 0
2120  RETURN
2130  '
2140  ' Subroutine, de-space Q$
2150  SP = INSTR(Q$," ")
2160  IF SP = 0 THEN 2220
2170  Q$ = LEFT$(Q$,SP-1) + MID$(Q$,SP+1)
2180  GOTO 2150
2190  RETURN
2200  '
2210  ' Subroutine, just capitalize Q$
2220  FOR QP = 1 TO LEN(Q$)
2230  CHAR$ = MID$(Q$,QP,1)
2240  IF CHAR$ < "a" OR CHAR$ > "z" THEN 2260
2250  MID$(Q$,QP,1) = CHR$(ASC(CHAR$)-32)
2260  NEXT QP
2270  RETURN
2280  '
2290  ' Subroutine, MONTH,DAY,YEAR to JULIAN,WEEKDAY
2300  JULIAN = INT(365.242 * YEAR + 30.44 * (MONTH-1) + DAY + 1)
2310  T1 = MONTH - 2 - 12 * (MONTH < 3)
2320  T2 = YEAR + (MONTH < 3)
2330  T3 = INT(T2 / 100)
2340  T2 = T2 - 100 * T3
2350  WEEKDAY = INT(2.61 * T1 - 0.2) + DAY + T2 + INT(T2 / 4)
2360  WEEKDAY = (WEEKDAY + INT(T3 / 4) - T3 - T3 + 77) MOD 7 + 1
2370  T4 = JULIAN - 7 * INT(JULIAN / 7)
2380  JULIAN = JULIAN - T4 + WEEKDAY + 7 * (T4 < WEEKDAY - 1) + 1.72106E+06
2390  RETURN
2400  '
2410  ' Subroutine, JULIAN to MONTH,DAY,YEAR,WEEKDAY
2420  T5 = JULIAN
2430  YEAR = INT((JULIAN - 1.72106E+06) / 365.25 + 1)
2440  MONTH = 1
2450  DAY = 1
2460  GOSUB 2300
2470  IF JULIAN <= T5 THEN 2500
2480  YEAR = YEAR - 1
2490  GOTO 2460
2500  MONTH = INT((T5 - JULIAN) / 29 + 1)
2510  GOSUB 2300
2520  IF JULIAN <= T5 THEN 2550
2530  MONTH = MONTH - 1
2540  GOTO 2510
2550  DAY = T5 - JULIAN + 1
2560  GOSUB 2300
2570  RETURN
2580  '
2590  ' Subroutine, convert CAL$ to MONTH,DAY,YEAR
2600  Q$ = CAL$
2610  GOSUB 2220
2620  CAL$ = Q$
2630  MONTH = 0
2640  DAY = 0
2650  YEAR = 0
2660  FOR I = 1 TO 12
2670  IF INSTR(CAL$,LEFT$(MONTH.NAME$(I),3)) THEN MONTH = I
2680  NEXT I
2690  FOR I = 1 TO LEN(CAL$)
2700  CHAR$ = MID$(CAL$,I,1)
2710  IF CHAR$ < "0" OR CHAR$ > "9" THEN MID$(CAL$,I,1) = ":"
2720  NEXT I
2730  IF INSTR(CAL$,":") THEN 2790
2740  IF LEN(CAL$) <> 6 AND LEN(CAL$) <> 8 THEN 3040
2750  MONTH = VAL(LEFT$(CAL$,2))
2760  DAY = VAL(MID$(CAL$,3,2))
2770  YEAR = VAL(MID$(CAL$,5))
2780  GOTO 2930
2790  VFLAG = 0
2800  FOR I = 1 TO LEN(CAL$)
2810  CALVAL = VAL(MID$(CAL$,I))
2820  IF CALVAL = 0 THEN VFLAG = 0
2830  IF CALVAL = 0 OR VFLAG = 1 THEN 2920
2840  IF MONTH THEN 2870
2850  MONTH = CALVAL
2860  GOTO 2910
2870  IF DAY THEN 2900
2880  DAY = CALVAL
2890  GOTO 2910
2900  YEAR = CALVAL
2910  VFLAG = 1
2920  NEXT I
2930  IF YEAR < 100 AND YEAR > 0 THEN YEAR = YEAR + 1900
2940  IF YEAR < 1582 OR YEAR > 3999 THEN YEAR = 0
2950  IF YEAR = 0 THEN 3040
2960  MONTH2 = MONTH
2970  DAY2 = DAY
2980  YEAR2 = YEAR
2990  GOSUB 2300
3000  GOSUB 2420
3010  IF MONTH2 <> MONTH THEN YEAR = 0
3020  IF DAY2 <> DAY THEN YEAR = 0
3030  IF YEAR2 <> YEAR THEN YEAR = 0
3040  RETURN